perm filename QUEEN3.LSP[E82,JMC] blob
sn#679488 filedate 1982-09-24 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 queen2.lsp[e82,jmc] Backtrackers for n queens
C00030 ENDMK
Cā;
;;;queen2.lsp[e82,jmc] Backtrackers for n queens
;;; This version attempts to terminate moves early when possible.
(defun solutions (pos sols)
(if (terp pos)
(if (winp pos) (cons (outform pos) sols) sols)
(do (
(m (moves pos) (cdr m))
(tried nil (cons (car m) tried))
(s1 sols (solutions (update (car m) pos) s1)))
((dead m pos) s1))))
(defun dead (m pos)
(if (or (null m)
(and (not (null tried))
(*catch 'lose
(prog ()
(delete1 (car tried) 'both)
(kill)))))
(do ((l takeback (cdr l)))
((null l))
(store (bd (rank (car l)) (file (car l))) 0))
nil)
)
(defun terp (pos)
(if (*catch 'noroom (let ((pp (rectify pos)))
(or (= nqueens n)
(do ((i 0 (1+ i))
(p t (and p (= (occfile i) n))))
((= i n) p)))))
(progn (setq ter-count (1+ ter-count)) t)
(prog ()
(setq takeback nil)
(setq onefile nil)
(setq twofile nil)
(setq threefile nil)
(setq onerank nil)
(setq tworank nil)
(setq threerank nil)
(do ((i 0 (1+ i)))
((= i n))
(if (= (occfile i) nm1) (push i onefile))
(if (= (occfile i) nm2) (push i twofile))
(if (= (occfile i) nm3) (push i threefile))
(if (= (occrank i) nm1) (push i onerank))
(if (= (occrank i) nm2) (push i tworank))
(if (= (occrank i) nm3) (push i threerank)))
(return nil)
)
))
;;; goes with complex nqueens
(defun update (move pos) (cons move pos))
;;; rectify and friends taken from McCarthy and Talcott
(defun rectify (p)
(prog (z q)
(setq q (commontail p p1))
l1 (if (equal q p1) (go l2))
(revert)
(go l1)
l2 (setq z (listsubt p p1))
l3 (if (null z) (return p))
(update (car z) pos)
(pop z)
(go l3)))
(defun commontail (u v) (reverse (commonhead (reverse u) (reverse v))))
(defun commonhead (u v) (if (or (null u) (null v) (not (equal (car u) (car v))))
nil
(cons (car u) (commonhead (cdr u) (cdr v)))))
(defun listsubt (u v) (listsubta u (- (length u) (length v)) nil))
(defun listsubta (u n z)
(if (zerop n)
z
(listsubta (cdr u) (1- n) (cons (car u) z))))
;;; Here is another version of rectify using do instead of the
;;; explicit loop. It doesn't seem more perspicuous to me.
(defun rectify (p)
(do ((z (listsubt p (do ((q (commontail p p1)))
((equal q p1) p1)
(revert))) (cdr z)))
((null z) p)
(update1 (car z) pos)))
(defun winp (pos) (= nqueens n))
;;; (moves pos) is the list of available squares in the file or rank with fewest
;;; available squares.
(defun moves (pos)
(do ((i 0 (1+ i))
(mf 0 (if (< (occfile i) n) (max mf (occfile i)) mf))
(mr 0 (if (< (occrank i) n) (max mr (occrank i)) mr))
(bf 0 (if (and (< (occfile i) n) (< mf (occfile i))) i bf))
(br 0 (if (and (< (occrank i) n) (< mr (occrank i))) i br)))
((= i n) (if (< mf mr) (avails-in-rank br) (avails-in-file bf)))))
;;; (outform sol) gives the complete solution rather than just the
;;; moves up to the point where there is no further backtracking.
(defun outform (pos) solution)
;;; update1 calls (move sq), but we'll keep the communication with
;;; the tree search program here.
(defun update1 (sq pos)
(prog ( )
(push (do ((i 0 (1+ i))
(l nil (cons (cons
(occfile (- nm1 i))
(occrank (- nm1 i))) l)))
((= i n) l))
stack)
(push nqueens stack)
(setq solution (*catch 'lose (move sq)))
(push takeback stack)
(push sq p1)
(if (equal solution 'noroom) (*throw 'noroom t))
(return (cons sq pos))))
(defun revert ()
(prog ()
(do ((l (car stack) (cdr l)))
((null l))
(store (bd (rank (car l)) (file (car l))) 0))
(pop stack)
(setq nqueens (car stack))
(pop stack)
(do ((i 0 (1+ i))
(l (car stack) (cdr l)))
((= i n))
(store (occfile i) (caar l))
(store (occrank i) (cdar l))
)
(pop stack)
(pop p1)
(return p1)
))
;;; second batch
(defun m (x y) (move (cons x y)))
(defun mb (x y) (prog () (move (cons x y)) (show)))
(defun delete1 (sq killflag)
(let* ((x (rank sq))
(y (file sq))
(or (1+ (occfile x)))
(of (1+ (occrank y))))
(prog ()
(if (not (zerop (bd x y))) (return nil))
(setq delete1-count (1+ delete1-count))
(store (bd x y) 1)
(push sq takeback)
(store (occfile x) or)
(store (occrank y) of)
(if (or (and (equal killflag 'both) (or (= n or) (= n of)))
(and (equal killflag 'rank) (= n or))
(and (equal killflag 'file) (= n of)))
(*throw 'lose 'noroom))
(if (= or nm1) (push x onefile))
(if (= or nm2) (push x twofile))
(if (= or nm3) (push x threefile))
(if (= of nm1) (push y onerank))
(if (= of nm2) (push y tworank))
(if (= of nm3) (push y threerank))
(return t)
)))
(defun occupy (sq)
(let ((x (rank sq)) (y (file sq)))
(delete1 sq nil)
(store (bd x y) 2)
(setq nqueens (1+ nqueens))
(do ((l1 (car (attack x y)) (cdr l1)))
((null l1)
)
(delete1 (car l1) 'rank))
(do ((l2 (cadr (attack x y)) (cdr l2)))
((null l2)
)
(delete1 (car l2) 'file))
(do ((l2 (caddr (attack x y)) (cdr l2)))
((null l2))
(delete1 (car l2) 'both))))
(DEFUN PRINTD (X) ((LAMBDA (U V) U) X (PRINT X)))
(defun move (sq)
(prog ()
(occupy sq)
(kill)
(return (if (= nqueens n) (mksol) 'nonsolution))))
;;; Now look for other squares that can be deleted.
(defun kill ()
(prog (sq1 u)
loop (if (null onefile) (go l1)) ; Files with only one possible space
; can be occupied immediately.
(setq u (avails-in-file (car onefile)))
(if (not (null u)) (go l1a))
(pop onefile)
(go loop)
l1a (setq sq1 (car u))
(pop onefile)
(occupy sq1)
(go loop)
l1 (if (null onerank) (go l2)) ; ranks with only one possible space
(setq u (avails-in-rank (car onerank)))
(if (not (null u)) (go l1b))
(pop onerank)
(go l1)
l1b (setq sq1 (car u))
(pop onerank)
(occupy sq1)
(go loop)
l2
(if (null twofile) (go l3)) ; files with two spaces. Find and delete
; squares that attack both.
(if (= (occfile (car twofile)) nm2) (go l2a))
(pop twofile)
(go l2)
l2a (setq u (k2f (avails-in-file (car twofile))))
(pop twofile)
(if (purge u) (go loop))
l3 (if (null tworank) (go l4))
(if (= (occrank (car tworank)) nm2) (go l3a))
(pop tworank)
(go l3)
l3a (setq u (k2r (avails-in-rank (car tworank))))
(pop tworank)
(if (purge u) (go loop))
l4 (if (null threefile) (go l5))
(if (= (occfile (car threefile)) nm3) (go l4a))
(pop threefile)
(go l4)
l4a (setq u (k3f (avails-in-file (car threefile))))
(pop threefile)
(if (purge u) (go loop))
l5 (if (null threerank) (go l6))
(if (= (occrank (car threerank)) nm3) (go l5a))
(pop threerank)
(go l5)
l5a (setq u (k3r (avails-in-rank (car threerank))))
(pop threerank)
(if (purge u) (go loop))
l6
;(SHOW)
;(PF NQUEENS)
(return nqueens)
))
(defun mksol ()
(do ((i (1- n) (1- i))
(sol nil
(cons (do ((j 0 (1+ j))
(y 0 (if (= (bd i j) 2) j y)))
((= j n) y)) sol)))
((= i -1) sol)))
;;; (k3f u) is the list of squares that might kill a file with three
;;; unexcluded squares.
(defun k3f (u)
(let ((d (- (file (car u)) (file (cadr u)))))
(if (= (- (file (cadr u)) (file (caddr u))) d)
(list (mksq (+ (rank (car u)) d) (file (cadr u)))
(mksq (- (rank (car u)) d) (file (cadr u))))
nil)))
;;; (k3r u) is the list of squares that might kill a rank with three
;;; unexcluded squares.
(defun k3r (u)
(let ((d (- (rank (car u)) (rank (cadr u)))))
(if (= (- (rank (cadr u)) (rank (caddr u))) d)
(list (mksq (rank (cadr u)) (+ (file (car u)) d))
(mksq (rank (cadr u)) (- (file (car u)) d)))
nil)))
(defun k2f (u)
(let ((d (- (file (car u)) (file (cadr u)))))
(if
(evenp d)
(append
(let ((d1 (quotient d 2)))
(list (mksq (+ (rank (car u)) d1) (- (file (car u)) d1))
(mksq (- (rank (car u)) d1) (- (file (car u)) d1))))
(k2f1 u d))
(k2f1 u d)
)))
;;; k2f1 called by k2f gets the killing squares when there are two
;;; squares left in a file and difference is odd.
(defun k2f1 (u d) (list
(mksq (+ (rank (car u)) d) (file (car u)))
(mksq (- (rank (car u)) d) (file (car u)))
(mksq (+ (rank (cadr u)) d) (file (cadr u)))
(mksq (- (rank (cadr u)) d) (file (cadr u)))
))
(defun k2r (u)
(let ((d (- (rank (car u)) (rank (cadr u)))))
(if
(evenp d)
(append
(let ((d1 (quotient d 2)))
(list (mksq (- (rank (car u)) d1) (+ (file (car u)) d1))
(mksq (- (rank (car u)) d1) (- (file (car u)) d1))))
(k2r1 u d))
(k2r1 u d)
)))
;;; k2r1 called by k2r gets the killing squares when there are two
;;; squares left in a rank and difference is odd.
(defun k2r1 (u d) (list
(mksq (rank (car u)) (+ (file (car u)) d))
(mksq (rank (car u)) (- (file (car u)) d))
(mksq (rank (cadr u)) (+ (file (cadr u)) d))
(mksq (rank (cadr u)) (- (file (cadr u)) d))
))
;;; Removes a list of squares from board checking that they are on the board
;;; and are unoccupied.
;;; Returns t if it found any, otherwise nil.
(defun purge (l)
(do ((l1 l (cdr l1))
(p nil (or p (and (lessp -1 (rank (car l1)) n)
(lessp -1 (file (car l1)) n)
(delete1 (car l1) t)))))
((null l1) p)))
(defun show () (prog ()
(pf onefile)(pf twofile)(pf threefile)(pf onerank)(pf tworank)(pf threerank)
(occprint)
(terpri)
(do i n (1- i) (= i 0)
(do j 0 (1+ j) (= j n) (show1 (bd j (1- i))))
(terpri)
)
)
)
(defun show1 (k) (prog ()
(princ (if (lessp k 8) " " " "))
(prin1 k)))
(defmacro pf (f)
`(progn (terpri) (princ (quote ,f)) (princ " = ")
(princ (symeval (quote ,f)))
,f))
(defun init (n2) (prog ()
(setq p1 nil) ; the list of moves to the position
(setq ter-count 0)
(setq delete1-count 0)
(setq n n2)
(setq nqueens 0)
(setq sols nil)
(array bd fixnum n n)
(array attack t n n)
(fill-attack n2)
(array occfile fixnum n)
(array occrank fixnum n)
(setq stack nil)
(setq nm1 (1- n))
(setq nm2 (- n 2))
(setq nm3 (- n 3))
; (setq onefile nil)
; (setq twofile nil)
; (setq threefile nil)
; (setq onerank nil)
; (setq tworank nil)
; (setq threerank nil)
(setq takeback nil)
))
;;; (fill-attack n) : initializes the arrray (attack x y) of squares
;;; attacked from square (x.y).
(defun fill-attack (n)
(do ((x 0 (1+ x)))
((= x n))
(do ((y 0 (1+ y)))
((= y n))
(prog (l)
(setq l1 nil l2 nil l3 nil)
(do ((x1 0 (1+ x1)))
((= x1 n))
(if (not (= x1 x)) (push (cons x1 y) l1)))
(do ((y1 0 (1+ y1)))
((= y1 n))
(if (not (= y1 y)) (push (cons x y1) l2)))
(do ((d (max (- x) (- y)) (1+ d)))
((= d (min (- n x) (- n y))))
(if (not (zerop d)) (push (cons (+ x d) (+ y d)) l3)))
(do ((d (max (- x) (- y (1- n))) (1+ d)))
((= d (min (- n x) (1+ y))))
(if (not (zerop d)) (push (cons (+ x d) (- y d)) l3)))
(store (attack x y) (list l1 l2 l3))))))
(defun mksq (x y) (cons x y))
(defun rank (sq) (car sq))
(defun file (sq) (cdr sq))
;;; (avails-in-file x) : unattacked squares in file x.
(defun avails-in-file (x)
(do ((j 0 (1+ j))
(u nil (if (zerop (bd x j)) (cons (mksq x j) u) u)))
((= j n) u)))
;;; (avails-in-rank x) : unattacked squares in rank x.
(defun avails-in-rank (y)
(do ((i 0 (1+ i))
(u nil (if (zerop (bd i y)) (cons (mksq i y) u) u)))
((= i n) u)))
;;; (occfile x): the number of occupants of file x.
;;; (occrank y): the number of occupants of rank y.
;;; (attack x y): the squares attacked from square x, y - a constant array.
;;; takeback: a list of the squares occupied in present recursion
(defmacro restore (vals . vars)
`(mapc #'set ',vars ,vals))
; for debugging
(DEFUN OCCPRINT () (PROG ()
(terpri)
(do ((i 0 (1+ i))) ((= i n)) (princ (occfile i)))
(terpri)
(do ((i 0 (1+ i))) ((= i n)) (princ (occrank i)))
terpri
))
(defun consistent ()
(and
(setq test 'occfile-bd)
(do ((i 0 (1+ i))
(p t (and
p
(= (occfile i) (do ((j 0 (1+ j))
(s 0 (if (plusp (bd i j)) (1+ s) s)))
((= j n) s))))))
((= i n) p))
(setq test 'occrank-bd)
(do ((j 0 (1+ j))
(p t (and
p
(= (occrank j) (do ((i 0 (1+ i))
(s 0 (if (plusp (bd i j)) (1+ s) s)))
((= i n) s))))))
((= j n) p))
(setq test 'nqueens-bd)
(= nqueens (do ((i 0 (1+ i))
(s 0 (+ s (do ((j 0 (1+ j))
(s1 0 (if (= (bd i j) 2) (1+ s1) s1)))
((= j n) s1)))))
((= i n) s)))
(setq test 'number-queens-on-file)
(do ((i 0 (1+ i))
(p t (and p (< (do ((j 0 (1+ j))
(s 0 (if (= (bd i j) 2) (1+ s) s)))
((= j n) s)) 2))))
((= i n) p))
(setq test 'number-queens-on-rank)
(do ((j 0 (1+ j))
(p t (and p (< (do ((i 0 (1+ i))
(s 0 (if (= (bd i j) 2) (1+ s) s)))
((= i n) s)) 2))))
((= j n) p))
))
;bfun
(untrace)
(trace dead ;delete1
kill rectify terp move update update1 moves winp revert occupy)
(init 6)
(solutions nil nil)
;ter-count
;delete1-count
;efun
;end
(OCCUPY REVERT WINP MOVES UPDATE1 UPDATE MOVE TERP RECTIFY KILL)
(DEAD KILL RECTIFY TERP MOVE UPDATE UPDATE1 MOVES WINP REVERT OCCUPY)
NIL
(1 ENTER TERP (NIL))
(1 ENTER RECTIFY (NIL))
(1 EXIT RECTIFY NIL)
(1 EXIT TERP NIL)
(1 ENTER MOVES (NIL))
(1 EXIT MOVES ((0 . 5) (0 . 4) (0 . 3) (0 . 2) (0 . 1) (0 . 0)))
(1 ENTER DEAD (((0 . 5) (0 . 4) (0 . 3) (0 . 2) (0 . 1) (0 . 0)) NIL))
(1 EXIT DEAD NIL)
(1 ENTER UPDATE ((0 . 5) NIL))
(1 EXIT UPDATE ((0 . 5)))
(1 ENTER TERP (((0 . 5))))
(1 ENTER RECTIFY (((0 . 5))))
(1 ENTER UPDATE1 ((0 . 5) ((0 . 5))))
(1 ENTER MOVE ((0 . 5)))
(1 ENTER OCCUPY ((0 . 5)))
(1 EXIT OCCUPY NIL)
(1 ENTER KILL NIL)
(1 EXIT KILL 1)
(1 EXIT MOVE NONSOLUTION)
(1 EXIT UPDATE1 ((0 . 5) (0 . 5)))
(1 EXIT RECTIFY ((0 . 5)))
(1 EXIT TERP NIL)
(1 ENTER MOVES (((0 . 5))))
(1 EXIT MOVES ((1 . 3) (1 . 2) (1 . 1) (1 . 0)))
(1 ENTER DEAD (((1 . 3) (1 . 2) (1 . 1) (1 . 0)) ((0 . 5))))
(1 EXIT DEAD NIL)
(1 ENTER UPDATE ((1 . 3) ((0 . 5))))
(1 EXIT UPDATE ((1 . 3) (0 . 5)))
(1 ENTER TERP (((1 . 3) (0 . 5))))
(1 ENTER RECTIFY (((1 . 3) (0 . 5))))
(1 ENTER UPDATE1 ((1 . 3) ((1 . 3) (0 . 5))))
(1 ENTER MOVE ((1 . 3)))
(1 ENTER OCCUPY ((1 . 3)))
(1 EXIT OCCUPY NIL)
(1 ENTER KILL NIL)
(1 ENTER OCCUPY ((3 . 4)))
(1 EXIT OCCUPY NIL)
(1 ENTER OCCUPY ((5 . 1)))
(1 EXIT TERP T)
(1 ENTER WINP (((1 . 3) (0 . 5))))
(1 EXIT WINP NIL)
(1 ENTER DEAD (((1 . 2) (1 . 1) (1 . 0)) ((0 . 5))))
(1 ENTER KILL NIL)
(1 ENTER OCCUPY ((2 . 0)))
(1 EXIT OCCUPY NIL)
(1 EXIT KILL 5)
(1 EXIT DEAD NIL)
(1 ENTER UPDATE ((1 . 2) ((0 . 5))))
(1 EXIT UPDATE ((1 . 2) (0 . 5)))
(1 ENTER TERP (((1 . 2) (0 . 5))))
(1 ENTER RECTIFY (((1 . 2) (0 . 5))))
(1 ENTER REVERT NIL)
(1 EXIT REVERT ((0 . 5)))
(1 ENTER UPDATE1 ((1 . 2) ((1 . 2) (0 . 5))))
(1 ENTER MOVE ((1 . 2)))
(1 ENTER OCCUPY ((1 . 2)))
(1 EXIT OCCUPY NIL)
(1 ENTER KILL NIL)
(1 ENTER OCCUPY ((3 . 3)))
(1 EXIT TERP T)
(1 ENTER WINP (((1 . 2) (0 . 5))))
(1 EXIT WINP NIL)
(1 ENTER DEAD (((1 . 1) (1 . 0)) ((0 . 5))))
(1 ENTER KILL NIL)
;NIL NON-NUMERIC VALUE
(show)
ONEFILE = NIL
TWOFILE = NIL
THREEFILE = (3 2 4 5 1)
ONERANK = NIL
TWORANK = (0 2)
THREERANK = (4 0 1 3 2)
665645
466646
2 1 1 1 1 1
1 1 1 1 0 0
1 1 1 2 1 1
1 2 1 1 1 1
1 1 1 1 1 1
1 1 2 1 0 1
NIL
stack
(((5 . 1) (3 . 1) (3 . 3) (4 . 3) (2 . 4) (5 . 3) (3 . 4) (2 . 1) (3 .
0) (1 . 0) (1 . 1) (1 . 3) (2 . 2) (4 . 2) (5 . 2) (1 . 2) (2 . 0) (4 .
2) (2 . 1) (5 . 1) (5 . 2) (4 . 4) (5 . 4) (3 . 4) (3 . 0) (2 . 4) (2 .
2) (3 . 1) (4 . 0) (1 . 0) (1 . 1) (1 . 2) (3 . 3) (4 . 3) (5 . 3) (1 .
3)) 1 ((6 . 2) (2 . 2) (2 . 2) (2 . 2) (2 . 2) (2 . 6)) ((1 . 4) (2 . 3)
(3 . 2) (4 . 1) (5 . 0) (0 . 0) (0 . 1) (0 . 2) (0 . 3) (0 . 4) (1 . 5)
(2 . 5) (3 . 5) (4 . 5) (5 . 5) (0 . 5)) 0 ((0 . 0) (0 . 0) (0 . 0) (0
. 0) (0 . 0) (0 . 0)))